home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / vm / vm-mouse.el < prev    next >
Encoding:
Text File  |  1995-08-15  |  16.1 KB  |  436 lines
  1. ;;; Mouse related functions and commands
  2. ;;; Copyright (C) 1995 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-mouse)
  19.  
  20. (defun vm-mouse-fsfemacs-mouse-p ()
  21.   (and (vm-fsfemacs-19-p)
  22.        (fboundp 'set-mouse-position)))
  23.  
  24. (defun vm-mouse-xemacs-mouse-p ()
  25.   (and (vm-xemacs-p)
  26.        (fboundp 'set-mouse-position)))
  27.  
  28. (defun vm-mouse-set-mouse-track-highlight (start end)
  29.   (cond ((fboundp 'make-overlay)
  30.      (let ((o (make-overlay start end)))
  31.        (overlay-put o 'mouse-face 'highlight)))
  32.     ((fboundp 'make-extent)
  33.      (let ((o (make-extent start end)))
  34.        (set-extent-property o 'highlight t)))))
  35.  
  36. (defun vm-mouse-button-2 (event)
  37.   (interactive "e")
  38.   ;; go to where the event occurred
  39.   (cond ((vm-mouse-xemacs-mouse-p)
  40.      (set-buffer (window-buffer (event-window event)))
  41.      (and (event-point event) (goto-char (event-point event))))
  42.     ((vm-mouse-fsfemacs-mouse-p)
  43.      (set-buffer (window-buffer (posn-window (event-start event))))
  44.      (goto-char (posn-point (event-start event)))))
  45.   ;; now dispatch depending on where we are
  46.   (cond ((eq major-mode 'vm-summary-mode)
  47.      (mouse-set-point event)
  48.      (beginning-of-line)
  49.      (if (let ((vm-follow-summary-cursor t))
  50.            (vm-follow-summary-cursor))
  51.          (progn
  52.            (vm-select-folder-buffer)
  53.            (vm-preview-current-message))
  54.        (setq this-command 'vm-scroll-forward)
  55.        (call-interactively 'vm-scroll-forward)))
  56.     ((memq major-mode '(vm-mode vm-virtual-mode))
  57.      (cond ((and (vm-mouse-fsfemacs-mouse-p) vm-url-browser)
  58.         (vm-mouse-popup-or-select event))))))
  59.  
  60. (defun vm-mouse-button-3 (event)
  61.   (interactive "e")
  62.   (if vm-use-menus
  63.       (progn
  64.     ;; go to where the event occurred
  65.     (cond ((vm-mouse-xemacs-mouse-p)
  66.            (set-buffer (window-buffer (event-window event)))
  67.            (and (event-point event) (goto-char (event-point event))))
  68.           ((vm-mouse-fsfemacs-mouse-p)
  69.            (set-buffer (window-buffer (posn-window (event-start event))))
  70.            (goto-char (posn-point (event-start event)))))
  71.     ;; now dispatch depending on where we are
  72.     (cond ((eq major-mode 'vm-summary-mode)
  73.            (vm-menu-popup-mode-menu event))
  74.           ((eq major-mode 'vm-mode)
  75.            (vm-menu-popup-context-menu event))
  76.           ((eq major-mode 'vm-virtual-mode)
  77.            (vm-menu-popup-context-menu event))
  78.           ((eq major-mode 'mail-mode)
  79.            (vm-menu-popup-mode-menu event))))))
  80.  
  81. (defun vm-mouse-3-help (object)
  82.   "Use mouse button 3 to see a menu of options.")
  83.  
  84. (defun vm-mouse-get-mouse-track-string (event)
  85.   (save-excursion
  86.     ;; go to where the event occurred
  87.     (cond ((vm-mouse-xemacs-mouse-p)
  88.        (set-buffer (window-buffer (event-window event)))
  89.        (and (event-point event) (goto-char (event-point event))))
  90.       ((vm-mouse-fsfemacs-mouse-p)
  91.        (set-buffer (window-buffer (posn-window (event-start event))))
  92.        (goto-char (posn-point (event-start event)))))
  93.     (cond ((fboundp 'overlays-at)
  94.        (let ((o-list (overlays-at (point)))
  95.          (string nil))
  96.          (while o-list
  97.            (if (overlay-get (car o-list) 'mouse-face)
  98.            (setq string (vm-buffer-substring-no-properties
  99.                  (overlay-start (car o-list))
  100.                  (overlay-end (car o-list)))
  101.              o-list nil)
  102.          (setq o-list (cdr o-list))))
  103.          string ))
  104.       ((fboundp 'extent-at)
  105.        (let ((e (extent-at (point) nil 'highlight)))
  106.          (if e
  107.          (buffer-substring (extent-start-position e)
  108.                    (extent-end-position e))
  109.            nil)))
  110.       (t nil))))
  111.  
  112. (defun vm-mouse-popup-or-select (event)
  113.   (interactive "e")
  114.   (cond ((vm-mouse-fsfemacs-mouse-p)
  115.      (set-buffer (window-buffer (posn-window (event-start event))))
  116.      (goto-char (posn-point (event-start event)))
  117.      (let (o-list o menu (found nil))
  118.        (setq o-list (overlays-at (point)))
  119.        (while (and o-list (not found))
  120.          (cond ((overlay-get (car o-list) 'vm-url)
  121.             (setq found t)
  122.             (vm-mouse-send-url-at-event event)))
  123.          (setq o-list (cdr o-list)))
  124.        (and (not found) (vm-menu-popup-context-menu event))))
  125.     ;; The XEmacs code is not actually used now, since all
  126.     ;; selectable objects are handled by an extent keymap
  127.     ;; binding that points to a more specific function.  But
  128.     ;; this might come in handy later if I want selectable
  129.     ;; objects that don't have an extent attached.
  130.     ((vm-mouse-xemacs-mouse-p)
  131.      (set-buffer (window-buffer (event-window event)))
  132.      (and (event-point event) (goto-char (event-point event)))
  133.      (if (extent-at (point) (current-buffer) 'vm-url)
  134.          (vm-mouse-send-url-at-event event)
  135.        (vm-menu-popup-context-menu event)))))
  136.  
  137. (defun vm-mouse-send-url-at-event (event)
  138.   (interactive "e")
  139.   (cond ((vm-mouse-xemacs-mouse-p)
  140.      (set-buffer (window-buffer (event-window event)))
  141.      (and (event-point event) (goto-char (event-point event)))
  142.      (vm-mouse-send-url-at-position (event-point event)))
  143.     ((vm-mouse-fsfemacs-mouse-p)
  144.      (set-buffer (window-buffer (posn-window (event-start event))))
  145.      (goto-char (posn-point (event-start event)))
  146.      (vm-mouse-send-url-at-position (posn-point (event-start event))))))
  147.  
  148. (defun vm-mouse-send-url-at-position (pos &optional browser)
  149.   (cond ((vm-mouse-xemacs-mouse-p)
  150.      (let ((e (extent-at pos (current-buffer) 'vm-url))
  151.            url)
  152.        (if (null e)
  153.            nil
  154.          (setq url (buffer-substring (extent-start-position e)
  155.                      (extent-end-position e)))
  156.          (vm-mouse-send-url url browser))))
  157.     ((vm-mouse-fsfemacs-mouse-p)
  158.      (let (o-list url o)
  159.        (setq o-list (overlays-at pos))
  160.        (while (and o-list (null (overlay-get (car o-list) 'vm-url)))
  161.          (setq o-list (cdr o-list)))
  162.        (if (null o-list)
  163.            nil
  164.          (setq o (car o-list))
  165.          (setq url (vm-buffer-substring-no-properties
  166.             (overlay-start o)
  167.             (overlay-end o)))
  168.          (vm-mouse-send-url url browser))))))
  169.  
  170. (defun vm-mouse-send-url (url &optional browser)
  171.   (let ((browser (or browser vm-url-browser)))
  172.     (cond ((symbolp browser)
  173.        (funcall browser url))
  174.       ((stringp browser)
  175.        (vm-unsaved-message "Sending URL to %s..." browser)
  176.        (vm-run-background-command browser url)
  177.        (vm-unsaved-message "Sending URL to %s... done" browser)))))
  178.  
  179. (defun vm-mouse-send-url-to-netscape (url &optional new-netscape new-window)
  180.   (vm-unsaved-message "Sending URL to Netscape...")
  181.   (if new-netscape
  182.       (vm-run-background-command vm-netscape-program url)
  183.     (or (equal 0 (vm-run-command vm-netscape-program "-remote" 
  184.                  (concat "openURL(" url
  185.                      (if new-window ", new-window" "")
  186.                      ")")))
  187.     (vm-mouse-send-url-to-netscape url t new-window)))
  188.   (vm-unsaved-message "Sending URL to Netscape... done"))
  189.  
  190. (defun vm-mouse-send-url-to-mosaic (url &optional new-mosaic new-window)
  191.   (vm-unsaved-message "Sending URL to Mosaic...")
  192.   (if (null new-mosaic)
  193.       (let ((pid-file "~/.mosaicpid")
  194.         (work-buffer " *mosaic work*")
  195.         pid)
  196.     (cond ((file-exists-p pid-file)
  197.            (set-buffer (get-buffer-create work-buffer))
  198.            (erase-buffer)
  199.            (insert-file-contents pid-file)
  200.            (setq pid (int-to-string (string-to-int (buffer-string))))
  201.            (erase-buffer)
  202.            (insert (if new-window "newwin" "goto") ?\n)
  203.            (insert url ?\n)
  204.            (write-region (point-min) (point-max)
  205.                  (concat "/tmp/Mosaic." pid)
  206.                  nil 0)
  207.            (set-buffer-modified-p nil)
  208.            (kill-buffer work-buffer)))
  209.     (cond ((or (null pid)
  210.            (not (equal 0 (vm-run-command "kill" "-USR1" pid))))
  211.            (setq new-mosaic t)))))
  212.   (if new-mosaic
  213.       (vm-run-background-command vm-mosaic-program url))
  214.   (vm-unsaved-message "Sending URL to Mosaic... done"))
  215.  
  216.  
  217. (defun vm-mouse-install-mouse ()
  218.   (cond ((vm-mouse-xemacs-mouse-p)
  219.      (if (null (lookup-key vm-mode-map 'button2))
  220.          (define-key vm-mode-map 'button2 'vm-mouse-button-2)))
  221.     ((vm-mouse-fsfemacs-mouse-p)
  222.      (if (null (lookup-key vm-mode-map [mouse-2]))
  223.          (define-key vm-mode-map [mouse-2] 'vm-mouse-button-2))
  224.      (if (null (lookup-key vm-mode-map [down-mouse-3]))
  225.          (progn
  226.            (define-key vm-mode-map [mouse-3] 'ignore)
  227.            (define-key vm-mode-map [down-mouse-3] 'vm-mouse-button-3))))))
  228.  
  229. (defun vm-run-background-command (command &rest arg-list)
  230.   (apply (function call-process) command nil 0 nil arg-list))
  231.  
  232. (defun vm-run-command (command &rest arg-list)
  233.   (apply (function call-process) command nil nil nil arg-list))
  234.  
  235. ;; stupid yammering compiler
  236. (defvar vm-mouse-read-file-name-prompt)
  237. (defvar vm-mouse-read-file-name-dir)
  238. (defvar vm-mouse-read-file-name-default)
  239. (defvar vm-mouse-read-file-name-must-match)
  240. (defvar vm-mouse-read-file-name-initial)
  241. (defvar vm-mouse-read-file-name-history)
  242. (defvar vm-mouse-read-file-name-return-value)
  243.  
  244. (defun vm-mouse-read-file-name (prompt &optional dir default
  245.                        must-match initial history)
  246.   "Like read-file-name, except uses a mouse driven interface.
  247. HISTORY argument is ignored."
  248.   (save-excursion
  249.     (or dir (setq dir default-directory))
  250.     (set-buffer (generate-new-buffer " *Files*"))
  251.     (use-local-map (make-sparse-keymap))
  252.     (setq buffer-read-only t
  253.       default-directory dir)
  254.     (make-local-variable 'vm-mouse-read-file-name-prompt)
  255.     (make-local-variable 'vm-mouse-read-file-name-dir)
  256.     (make-local-variable 'vm-mouse-read-file-name-default)
  257.     (make-local-variable 'vm-mouse-read-file-name-must-match)
  258.     (make-local-variable 'vm-mouse-read-file-name-initial)
  259.     (make-local-variable 'vm-mouse-read-file-name-history)
  260.     (make-local-variable 'vm-mouse-read-file-name-return-value)
  261.     (setq vm-mouse-read-file-name-prompt prompt)
  262.     (setq vm-mouse-read-file-name-dir dir)
  263.     (setq vm-mouse-read-file-name-default default)
  264.     (setq vm-mouse-read-file-name-must-match must-match)
  265.     (setq vm-mouse-read-file-name-initial initial)
  266.     (setq vm-mouse-read-file-name-history history)
  267.     (setq vm-mouse-read-file-name-prompt prompt)
  268.     (setq vm-mouse-read-file-name-return-value nil)
  269.     (save-excursion
  270.       (vm-goto-new-frame 'completion))
  271.     (switch-to-buffer (current-buffer))
  272.     (vm-mouse-read-file-name-event-handler)
  273.     (save-excursion
  274.       (local-set-key "\C-g" 'vm-mouse-read-file-name-quit-handler)
  275.       (recursive-edit))
  276.     ;; buffer could have been killed
  277.     (and (boundp 'vm-mouse-read-file-name-return-value)
  278.      (prog1
  279.          vm-mouse-read-file-name-return-value
  280.        (kill-buffer (current-buffer))))))
  281.  
  282. (defun vm-mouse-read-file-name-event-handler (&optional string)
  283.   (let ((key-doc "Click here for keyboard interface.")
  284.     start list)
  285.     (if string
  286.     (cond ((equal string key-doc)
  287.            (condition-case nil
  288.            (save-excursion
  289.              (save-excursion
  290.                (let ((vm-mutable-frames t))
  291.              (vm-delete-windows-or-frames-on (current-buffer))))
  292.              (setq vm-mouse-read-file-name-return-value
  293.                (vm-keyboard-read-file-name
  294.                 vm-mouse-read-file-name-prompt
  295.                 vm-mouse-read-file-name-dir
  296.                 vm-mouse-read-file-name-default
  297.                 vm-mouse-read-file-name-must-match
  298.                 vm-mouse-read-file-name-initial
  299.                 vm-mouse-read-file-name-history))
  300.              (vm-mouse-read-file-name-quit-handler t))
  301.          (quit (vm-mouse-read-file-name-quit-handler))))
  302.           ((file-directory-p string)
  303.            (setq default-directory (expand-file-name string)))
  304.           (t (setq vm-mouse-read-file-name-return-value
  305.                (expand-file-name string))
  306.          (vm-mouse-read-file-name-quit-handler t))))
  307.     (setq buffer-read-only nil)
  308.     (erase-buffer)
  309.     (setq start (point))
  310.     (insert vm-mouse-read-file-name-prompt)
  311.     (vm-set-region-face start (point) 'bold)
  312.     (cond ((and (not string) vm-mouse-read-file-name-default)
  313.        (setq start (point))
  314.        (insert vm-mouse-read-file-name-default)
  315.        (vm-mouse-set-mouse-track-highlight start (point)))
  316.       ((not string) nil)
  317.       (t (insert default-directory)))
  318.     (insert ?\n ?\n)
  319.     (setq start (point))
  320.     (insert key-doc)
  321.     (vm-mouse-set-mouse-track-highlight start (point))
  322.     (vm-set-region-face start (point) 'italic)
  323.     (insert ?\n ?\n)
  324.     (setq list (directory-files default-directory))
  325.     (vm-show-list list 'vm-mouse-read-file-name-event-handler)
  326.     (setq buffer-read-only t)))
  327.  
  328. (defun vm-mouse-read-file-name-quit-handler (&optional normal-exit)
  329.   (interactive)
  330.   (let ((vm-mutable-frames t))
  331.     (vm-delete-windows-or-frames-on (current-buffer))
  332.     (if normal-exit
  333.     (throw 'exit nil)
  334.       (throw 'exit t))))
  335.  
  336. (defvar vm-mouse-read-string-prompt)
  337. (defvar vm-mouse-read-string-completion-list)
  338. (defvar vm-mouse-read-string-multi-word)
  339. (defvar vm-mouse-read-string-return-value)
  340.  
  341. (defun vm-mouse-read-string (prompt completion-list &optional multi-word)
  342.   (save-excursion
  343.     (set-buffer (generate-new-buffer " *Choices*"))
  344.     (use-local-map (make-sparse-keymap))
  345.     (setq buffer-read-only t)
  346.     (make-local-variable 'vm-mouse-read-string-prompt)
  347.     (make-local-variable 'vm-mouse-read-string-completion-list)
  348.     (make-local-variable 'vm-mouse-read-string-multi-word)
  349.     (make-local-variable 'vm-mouse-read-string-return-value)
  350.     (setq vm-mouse-read-string-prompt prompt)
  351.     (setq vm-mouse-read-string-completion-list completion-list)
  352.     (setq vm-mouse-read-string-multi-word multi-word)
  353.     (setq vm-mouse-read-string-return-value nil)
  354.     (save-excursion
  355.       (vm-goto-new-frame 'completion))
  356.     (switch-to-buffer (current-buffer))
  357.     (vm-mouse-read-string-event-handler)
  358.     (save-excursion
  359.       (local-set-key "\C-g" 'vm-mouse-read-string-quit-handler)
  360.       (recursive-edit))
  361.     ;; buffer could have been killed
  362.     (and (boundp 'vm-mouse-read-string-return-value)
  363.      (prog1
  364.          (if (listp vm-mouse-read-string-return-value)
  365.          (mapconcat 'identity vm-mouse-read-string-return-value " ")
  366.            vm-mouse-read-string-return-value)
  367.        (kill-buffer (current-buffer))))))
  368.  
  369. (defun vm-mouse-read-string-event-handler (&optional string)
  370.   (let ((key-doc  "Click here for keyboard interface.")
  371.     (bs-doc   "      .... to go back one word.")
  372.     (done-doc "      .... to when you're done.")
  373.     start list)
  374.     (if string
  375.     (cond ((equal string key-doc)
  376.            (condition-case nil
  377.            (save-excursion
  378.              (save-excursion
  379.                (let ((vm-mutable-frames t))
  380.              (vm-delete-windows-or-frames-on (current-buffer))))
  381.              (setq vm-mouse-read-string-return-value
  382.                (vm-keyboard-read-string
  383.                 vm-mouse-read-string-prompt
  384.                 vm-mouse-read-string-completion-list
  385.                 vm-mouse-read-string-multi-word))
  386.              (vm-mouse-read-string-quit-handler t))
  387.          (quit (vm-mouse-read-string-quit-handler))))
  388.           ((equal string bs-doc)
  389.            (setq vm-mouse-read-string-return-value
  390.              (nreverse
  391.               (cdr
  392.                (nreverse vm-mouse-read-string-return-value)))))
  393.           ((equal string done-doc)
  394.            (vm-mouse-read-string-quit-handler t))
  395.           (t (setq vm-mouse-read-string-return-value
  396.                (nconc vm-mouse-read-string-return-value
  397.                   (list string)))
  398.          (if (null vm-mouse-read-string-multi-word)
  399.              (vm-mouse-read-string-quit-handler t)))))
  400.     (setq buffer-read-only nil)
  401.     (erase-buffer)
  402.     (setq start (point))
  403.     (insert vm-mouse-read-string-prompt)
  404.     (vm-set-region-face start (point) 'bold)
  405.     (insert (mapconcat 'identity vm-mouse-read-string-return-value " "))
  406.     (insert ?\n ?\n)
  407.     (setq start (point))
  408.     (insert key-doc)
  409.     (vm-mouse-set-mouse-track-highlight start (point))
  410.     (vm-set-region-face start (point) 'italic)
  411.     (insert ?\n)
  412.     (if vm-mouse-read-string-multi-word
  413.     (progn
  414.       (setq start (point))
  415.       (insert bs-doc)
  416.       (vm-mouse-set-mouse-track-highlight start (point))
  417.       (vm-set-region-face start (point) 'italic)
  418.       (insert ?\n)
  419.       (setq start (point))
  420.       (insert done-doc)
  421.       (vm-mouse-set-mouse-track-highlight start (point))
  422.       (vm-set-region-face start (point) 'italic)
  423.       (insert ?\n)))
  424.     (insert ?\n)
  425.     (vm-show-list vm-mouse-read-string-completion-list
  426.           'vm-mouse-read-string-event-handler)
  427.     (setq buffer-read-only t)))
  428.  
  429. (defun vm-mouse-read-string-quit-handler (&optional normal-exit)
  430.   (interactive)
  431.   (let ((vm-mutable-frames t))
  432.     (vm-delete-windows-or-frames-on (current-buffer))
  433.     (if normal-exit
  434.     (throw 'exit nil)
  435.       (throw 'exit t))))
  436.